
; A frame contains information about a procedure's current stack frame.  It
; also has a list of the literals that will go in the procedure's template
; and the debugging data for the template.
;
; template-index - the location of this procedure's template in the frame
;                  (#f if the template is not needed)
; env-index      - the location of this procedure's environment in the frame
;                  (#f if the procedure does not use its environment)
; closure-index  - the location of this procedure's closure in the frame
;                  (#f if the closure is not needed)
; size		 - largest size reached by the frame, in descriptors (not including register space!)
; literals	 - list of literals and bindings referenced
; count		 - length of LITERALS
; debug-data	 - debug information (see ddata.scm)
; first-register - first allocated register index (below that are the function parameters)
; registers      - assoc list of (register . ref-count)

(define-record-type frame :frame
  (really-make-frame literals count debug-data template-index env-index closure-index size first-register registers)
  frame?
  (template-index frame-template-index)
  (env-index      frame-env-index)
  (closure-index  frame-closure-index)
  (size           frame-size     set-frame-size!)
  (literals       frame-literals set-frame-literals!)
  (count	  frame-count    set-frame-count!)
  (debug-data     frame-debug-data)
  (first-register frame-first-register)
  (registers      frame-registers set-frame-registers!))

; SIZE is the number of values on the stack when the procedure is
; entered (typically the number of arguments).  ENV? is true if the
; environment was pushed on after the arguments, TEMPLATE? is true if
; the template was pushed as well.  CLOSURE? is true if the closure
; was pushed as well.

(define (make-frame parent name size template? env? closure?)
  (let* ((ddata (new-debug-data (adjust-procedure-name name)
				(if parent
				    (frame-debug-data parent)
				    #f))))
    
    (define (allocate-index really?)
      (and really?
	   (let ((index size))
	     (set! size (+ 1 size))
	     index)))

    (let* ((closure-index (allocate-index closure?))
	   (env-index (allocate-index env?))
	   (template-index (allocate-index template?)))

      (really-make-frame '()
			 0
			 ddata
			 template-index env-index closure-index
			 size
			 size ; first register index
                         '()))))

(define (adjust-procedure-name name)
  (cond ((string? name)			; only files have strings for names
	 (if (keep-file-names?)
	     name
	     #f))
	((and (keep-procedure-names?)
	      (name? name))
	 (name->symbol name))
	(else
	 #f)))

(define (frame-register-count frame)
  (length (frame-registers frame)))

; frame size + frame's register size
; This will only be correct after the code for that frame is fully compiled!
;
(define (full-frame-size frame)
  (+ (frame-size frame)
     (frame-register-count frame)))

; Note that FRAME reaches a size of DEPTH.
; This is the depth without any registers

(define (depth-check! frame depth)
  (if (< (frame-size frame) depth)
      (set-frame-size! frame depth)))

; These two procedures look up bindings and literals in the list of values
; to go in the template.  They're added if not already present.  The returned
; index is that of template, not the frame's list.

(define (binding->index frame binding name assigned?)
  (let loop ((i 0) (l (frame-literals frame)))
    (cond ((null? l)
	   (really-literal->index frame 
				  (make-thingie binding name assigned?)
				  #f))
	  ((and (thingie? (car l))
		(eq? binding (thingie-binding (car l)))
		(eq? name (thingie-name (car l))))
	   (if assigned?
	       (set-thingie-assigned?! (car l) #t))
	   (really-literal->index frame #f i))
	  (else
	   (loop (+ i 1) (cdr l))))))

(define (literal->index frame thing)
  (really-literal->index frame thing
			 (position thing (frame-literals frame))))

(define (really-literal->index frame thing probe)
  (let ((count (frame-count frame)))
    (if probe
	;; +++  Eliminate duplicate entries.
	;; Not necessary, just a modest space saver [how much?].
	;; Measurably slows down compilation.
	;; when 1 thing, lits = (x), count = 1, probe = 0, want 2
	(+ (- count probe)
	   (- template-overhead 1))
	(begin
	  (if (>= count two-byte-limit)
	      (assertion-violation 'literal->index
				   "compiler bug: too many literals"
				   thing))
	  (set-frame-literals! frame
			       (cons thing
				     (frame-literals frame)))
	  (set-frame-count! frame (+ count 1))
	  ;; when 1st thing, count = 0, want 2
	  (+ count template-overhead)))))

(define (position elt list)
  (let loop ((i 0) (l list))
    (cond ((null? l)
	   #f)
	  ((equal? elt (car l))
	   i)
	  (else
	   (loop (+ i 1) (cdr l))))))

; -----------------------------------------------
; Register allocation

(define (register-error caller message frame . maybe-register)
  (apply assertion-violation
         caller
         message
         (append
           maybe-register
           (frame-registers frame))))

; Allocates a new regiester
; The register starts with a ref-count of 1, which means the next free-register call will
; mark it as free again
;
(define (allocate-register frame)  
  (let loop ((registers (frame-registers frame)))       ; look for a register with ref-count 0
    (cond  
      ((null? registers)                                ; nothing found, need a new register
       (let ((new (+ (frame-first-register frame)
                     (length (frame-registers frame)))))
         (if (> new 255)
             (register-error 'allocate-register "compiler-problem: out of register indexes!" frame))
         (set-frame-registers! frame
           (cons (cons new 1) (frame-registers frame))) ; the new register starts with a 1 ref-count
         new))
      ((= 0 (cdar registers))                           ; a free register
       (set-cdr! (car registers) 1)
       (caar registers))
      (else
       (loop (cdr registers))))))

; Add a reference to a register. This prevents it from being freed in a subsequent free-register call
; This is used whenever a local variable is returned instead of a newly allocated register to prevent
; the local variable slot from being freed prematurely
;
(define (add-register-reference frame register)
  (let ((entry (assoc register (frame-registers frame))))
    (cond      
      ; nothin to do in this case, as function parameters are never freed anyway
      ((< register (frame-first-register frame)))
      ; some debugging help
      ((not entry)
       (register-error 'add-register-reference "unknown register" frame register))
      ((= 0 (cdr entry))
       (register-error 'add-register-reference "cannot reference a free register" frame register))
      (else
       (set-cdr! entry (+ (cdr entry) 1))))))
 
 
; Determines wether register is reusable or not 
; A register is reusable if it is not a procedure parameter and has a ref-count of one.
; (this essentially means that the caller is the only one referencing the register, 
;  so he can overwrite it at will)
;
(define (register-reusable? frame register)
  (let ((entry (assoc register (frame-registers frame))))
    (cond
      ((< register (frame-first-register frame))
       #f) ; a function parameter
      ((not entry)
       (register-error 'register-reusable? "unknown register" frame register))
      ((= 0 (cdr entry))
       #t)
      (else
       #f))))

; Decrease the reference count of a register
; The register becomes available for reuse when the count is 0
;
(define (free-register frame . registers)
  (let loop ((registers registers))
    (cond 
      ;; terminate
      ((null? registers)) 
      ;; function parameters are never freed
      ((< (car registers) (frame-first-register frame))
       (loop (cdr registers)))       
      (else
       (let ((entry (assoc (car registers) (frame-registers frame))))
         (cond 
           ((not entry)
            (register-error 'free-register "unknown register" frame (car registers)))
           ((< (cdr entry) 1)
            (register-error 'free-register "double-free of a register" frame (car registers)))
           (else
            (set-cdr! entry (- (cdr entry) 1)))))
       (loop (cdr registers)))))
      
   ; Return an empty segment here, so this function can be used inside (sequentially ...)
   ; To not introduce a circular dependency, create the empty-segment manually (its (cons size emitter))
   ; This is a bit of a hack, but it makes the usage of this function much simpler
   (cons 0 (lambda (astate) #f)))



